home *** CD-ROM | disk | FTP | other *** search
/ CU Amiga Super CD-ROM 27 / CU Amiga Magazine's Super CD-ROM 27 (1998)(EMAP Images)(GB)[!][issue 1998-10].iso / CUCD / Programming / JForth / Extras / SysGen / buildsys < prev    next >
Encoding:
Text File  |  1992-06-01  |  19.3 KB  |  786 lines
  1. decimal
  2.  
  3. headtail on
  4.  
  5. : version#    3100     inline ;
  6.  
  7. : immediate   latest c@ $ 40 or latest c!   ;
  8.  
  9. : (    $ 29 word drop    ;  immediate
  10.  
  11. ( ------------------ CHANGE HISTORY ----------------- )
  12.  
  13. ( 00001 18-aug-91 mdh     Incorporated XBLK )
  14. ( 00002 13-sep-91 mdh     wb2.0 changes )
  15. ( 00003 11-oct-91 mdh     fixed 'SAVE-FORTH COM:minimum' message )
  16.  
  17. : depth
  18.   sp@ s0 @ swap - cell/  ;
  19.  
  20. : CONSOLE@ ( -- console-in-use , stdout )
  21.     consoleout @ ;
  22.  
  23. : skip-word   true skip-word? !  ;
  24. : skipword    skip-word  ;
  25.  
  26. : [compile]  ( -- , <name> )
  27.   $ 20 word  find 0= 0 ?error   cfa,    ;   immediate
  28.  
  29. : '  ( -- cfa , <name> )
  30.   $ 20 word  find  0= 0 ?error [compile] aliteral ;   immediate
  31.  
  32. : cell 4 inline ;
  33.  
  34. : ABSW!  ( w1 adr1 -- )
  35.   [ $ 2047,30ae ,   $ 2,588e ,  $ 2e1e w, ]  inline ;
  36.  
  37.  
  38. : ? @ . ;
  39.  
  40.  
  41. (  -----------VARIABLE, CONSTANT, USER, FREEZE, ?TERMINAL...   )
  42.  
  43. max-inline @  6 max-inline !
  44.  
  45. : CONSTANT  ( -- , <name> , allocate a constant )
  46. ( takes advantage of the smart literal...  )
  47.   :create      ( make the name field... )
  48.   here >r      ( save addr... )
  49.   state @ >r  1 state !
  50.   [compile] literal   r> state !
  51.   here r -  ( negate ) $ 8000,0000 or  r> cell- !
  52.   unsmudge
  53.   $ 4e75 w,    ;
  54.  
  55. max-inline !
  56.  
  57. $ 400,0000 constant TAIL_BIT
  58. $ 200,0000 constant CLASS_BIT   ( marks an ODE Class child )
  59. $ 100,0000 constant :CLASS_BIT  ( marks an ODE Class parent )
  60.  
  61. ( -- TAIL now after conditionals ) 
  62. ( : tail  latest name> cell- dup @  tail_bit or  swap !  ; immediate )
  63.  
  64.   $   4EAB constant JSR+64K-CODE
  65.   $   4EAC constant JSR+ORG-CODE
  66.   $ 1,0000 constant 64k
  67.   $ 1,0000 constant VARIABLE_ID
  68.   $ 2,0000 constant USER_ID
  69.   $ 3,0000 constant CREATE_ID
  70. ( $ 4,0000 constant USERDEF_ID )
  71.   $ 5,0000 constant GLOBDEF_ID   ( now both are the same... )
  72. GLOBDEF_ID constant USERDEF_ID
  73.   $ 6,0000 constant VALUE_ID
  74.  
  75. ( -----------  CONDITIONALS & CONTROL/LOOPING STRUCTURES...  )
  76.  
  77. decimal
  78.  
  79. : bl 32 ;
  80.  
  81. : >us  ( n --- )   usp @  cell-  ( ?us-error ) dup usp !    ! ;
  82.  
  83. : us>  ( --- n )   usp @ ( ?us-error )  @ cell  usp +!  ;  ' us> 'usp> !
  84.  
  85. : us@  ( --- n )   usp @ ( ?us-error )  @ ; 
  86.  
  87.  
  88. max-inline @  20 max-inline !
  89.  
  90. ( : NOT0BRANCH  ( FLAG --- )
  91. (     0= 0BRANCH  inline ; )
  92.  
  93. : NOT0BRANCH  ( FLAG --- )
  94. [ $ 4a87 w,        ( tst.l  tos          )
  95.   $ 4cde,0080  ,   ( movem.l {dsp}+,tos  )
  96.   $ 6600,0000  ,   ( bne     ??          )
  97. ] inline ;     
  98.  
  99. max-inline !
  100.  
  101.  
  102. ( 1 constant ) : begin_flag 1 inline ; 
  103.  
  104. ( 2 constant ) : if_flag    2 inline ;
  105.  
  106. ( 3 constant ) : do_flag    3 inline ;  
  107.  
  108. ( 4 constant ) : leave_flag 4 inline ;
  109.  
  110. ( 5 constant ) : ?do_flag   5 inline ;
  111.  
  112. : OptimizeOFF   IfOptimize OFF ;
  113. : BACK    ( adr --- )
  114.   ( flushopts )  ?comp HERE  -  2+   HERE  2-  W!  OptimizeOFF  ;
  115. ( Note that BACK is for 0BRANCH and NOT0BRANCH only! )
  116.  
  117. : BEGIN   ( run: ---) ( comp: --- here 1 )
  118.   ?COMP HERE  begin_flag   OptimizeOFF  ;
  119.     IMMEDIATE
  120.  
  121. : FORWARD  ( adr --- )
  122. ( flushopts )  ?comp HERE  dup last-forward-addr !
  123.   OVER - 2+ swap 2- W!  UseShortIf off  OptimizeOFF  ;
  124.  
  125. : THEN  ( run: --- ) ( comp: adr 2 --- )  ?COMP if_flag ?PAIRS forward ;
  126.     IMMEDIATE
  127.  
  128. : []  [compile]  [compile] ; immediate
  129.  
  130.  
  131. ( compiles the cfa of the word following )
  132. : compile  ( --- ) ?comp  [] '  ' cfa, cfa,  ; immediate
  133.  
  134. : (C0B)  compile 0branch  ;    ' (C0B) 'C0B !
  135.  
  136. : COMPILE0BRANCH   'C0B @execute   ;
  137.  
  138. : UNTIL ( ADR begin_flag <leave_pairs...> --- )   
  139.   ?comp    begin_flag ?PAIRS    COMPILE0BRANCH   BACK    ; IMMEDIATE
  140.  
  141. : END ( adr begin_flag --- ) ?comp  [] UNTIL ; IMMEDIATE
  142.  
  143. : AGAIN ( adr begin_flag --- )  ?comp
  144.       begin_flag ?PAIRS  COMPILE  BRANCH   BACK 
  145.         ; IMMEDIATE
  146.  
  147. : REPEAT ( adr begin_flag wadr while-flag --- )    
  148.   ?comp    >R >R [] AGAIN R> R> ( CELL- )
  149.         [] THEN       ; IMMEDIATE
  150.  
  151. : IF ( --- adr if_flag )  ?comp COMPILE0BRANCH HERE  if_flag
  152.   OptimizeOFF   ; IMMEDIATE
  153.  
  154.  
  155. : IF-NOT ( --- adr if_flag )  ?comp COMPILE NOT0BRANCH HERE  if_flag
  156.   OptimizeOFF   ; IMMEDIATE
  157.  
  158. : ELSE ( adr if_flag --- adr if_flag )
  159.   ?comp if_flag ?PAIRS COMPILE BRANCH HERE
  160.   SWAP  forward  (   if_flag   [] THEN   ) if_flag  ; IMMEDIATE
  161.  
  162. : WHILE ( --- adr while_flag )  ?comp compile0branch here if_flag
  163.   OptimizeOFF   ; IMMEDIATE
  164.  
  165. : WHILE-NOT ( --- adr while_flag )  ?comp compile NOT0branch here if_flag
  166.   OptimizeOFF ; IMMEDIATE
  167.  
  168. : UNTIL-NOT ( ADR begin_flag <leave_pairs...>--- )    ?comp
  169.     begin_flag  ?PAIRS
  170.     COMPILE  NOT0BRANCH   BACK    ; IMMEDIATE
  171.  
  172. ( DO LOOP support )
  173.  
  174. : DO    ( --- )   ( --us-- loop-back do_flag laddr  ?do_flag )  ?comp
  175.   ( flushopts )
  176.     HERE  2+  ( leave-adr  )  OptimizeOFF  COMPILE (?DO) 
  177.     HERE  >us   do_flag >us       >us  ?do_flag >us 
  178.     OptimizeOFF  ; IMMEDIATE
  179.  
  180. : LEAVE  ( --- )   ( --us-- resolve  leave_flag )  ?comp  ( flushopts )
  181.    HERE 6 + >us OptimizeOFF
  182.    COMPILE (LEAVE)   leave_flag >us      ; IMMEDIATE
  183.  
  184. : ?LEAVE     ( --- )  ( --us-- resolve  leave_flag )  ?comp  ( flushopts )
  185.    HERE $ 0e + >us  OptimizeOFF COMPILE (?LEAVE)   leave_flag >us ; IMMEDIATE
  186.  
  187. : ?STAY     ( --- )  ( --us-- resolve  leave_flag )  ?comp
  188.    COMPILE not  HERE $ 0e + >us  
  189.    OptimizeOFF compile (?leave)   leave_flag >us ; IMMEDIATE
  190.  
  191. : -DO     ( --- loop-back  do_flag )
  192.    ?comp COMPILE (DO)
  193.    HERE  >us  do_flag  >us  OptimizeOFF  ; IMMEDIATE
  194.  
  195.  
  196. : LOOP-FORWARD  ( --- )  (  [resolves  leave_flag ...]  --us-- )
  197.    BEGIN   us@   leave_flag =  us@ ?do_flag = or
  198.    WHILE   ( <?do>, leave or ?leave was used )  ( flushopts )
  199.           us>   leave_flag =
  200.           IF    us> here          dup>r over -  swap w!
  201.           ELSE  us> dup 8 +  here dup>r swap -  swap !
  202.           THEN
  203.           r> last-forward-addr !
  204.   REPEAT  OptimizeOFF  ;
  205.  
  206. : LOOP-BACK  ( do-adr do-flag --us-- ) ( flushopts )
  207.    us>  do_flag ?PAIRS  us>   HERE  -  6 +   HERE  6 -  W!
  208.    OptimizeOFF  ;
  209.  
  210. : LOOP   ( --- )  ( HERE do_flag ... HERE do_flag --R-- )  ?comp
  211.    COMPILE (LOOP)  loop-forward  LOOP-BACK  ; IMMEDIATE    
  212.     
  213. : +LOOP  ( N -- , at run time ) ?comp
  214.    COMPILE (+LOOP) loop-forward  LOOP-BACK   ; IMMEDIATE
  215.  
  216. : -LOOP ( N -- ) ?comp
  217.    COMPILE (-LOOP) loop-forward  LOOP-BACK ; IMMEDIATE
  218.  
  219. : SMARTC0B  ( -- , smart COMPILE0BRANCH )
  220.   ( flushopts )  UseShortIf @  ?dup
  221.   IF
  222.      ( -- last-called-cfa )  LastHere @ dp !
  223.      dup 2- w@ 2+ +   ( -- 1st-adr-FAST-code )
  224.      BEGIN
  225.         dup w@ dup $ 4e75 -   ( -- adr opcode flag )
  226.      WHILE
  227.         w,  2+
  228.      REPEAT
  229.      2drop
  230.   ELSE
  231.      (C0B)
  232.   THEN
  233. ;              ' SmartC0B  'C0B !
  234. decimal
  235.  
  236. : \  ( -- , comment out rest of line )
  237.   LASTSCAN @ $ 0A = 0=
  238.   tib >in @ + c@ $ 0a = 0=   and
  239.   IF
  240.      $ 0a word drop
  241.   THEN
  242. ; IMMEDIATE
  243.  
  244.  
  245. (    IF  #TIB @ >IN @ )
  246. (        DO i TIB + c@ )
  247. (           i 1+ >in ! )
  248. (           $ 0a = ?leave )
  249. (        LOOP )
  250. ( \ >in @ #tib @ >= IF BL WORD DROP >in OFF THEN )
  251. (    THEN )
  252.  
  253. \ now let's see if this type    comment works!
  254.  
  255. max-inline @  6 max-inline !
  256.  
  257. : SETVARSFA  ( <sfa> -- <sfa>' )
  258.   $ 3fff,ffff and   InlineVars @
  259.   IF
  260.        $ 8000,0000
  261.   ELSE
  262.        $ 4000,0000
  263.   THEN or
  264. ;
  265.  
  266. \ note: 'CLRCHAR' is defined in the kernal as a global variable, and holds the
  267. \ ascii char to send to the screen to clear it.  It is used here as a template.
  268. \
  269. \ a different 'variable' structure is assembled if compiling to a
  270. \ module because the normal (optimized) variable code does not work there.
  271.  
  272. : MyRTS+2
  273.   [
  274.     ( move.l  tos,-<dsp> )   $ 2D07  w,
  275.     ( move.l  <rp>,tos   )   $ 2E17  w,
  276.     ( sub.l   org,tos    )   $ 9E8C  w,
  277.     ( addq.l  #$2,tos    )   $ 5487  w,
  278.   ]
  279. ;
  280.  
  281.  
  282. : VARIABLE  ( -- , <name> , allocate a global variable )
  283.   \
  284.   \ inside the dictionary?
  285.   \
  286.   here  0 sp@  within?
  287.   IF
  288.      \
  289.      \ build a normal definition
  290.      \
  291.      :create                          \ make the name field...
  292.      here >r                         \ save addr...
  293.      ' clrchar  ( fromaddr -- )        \ asm args to move code...
  294.      r      ( fromaddr toaddr -- )
  295.      [ ' clrchar cell- @ $ ffff and 2+ ] literal     ( fromaddr toaddr cnt -- )
  296.      dup >r  move r> allot
  297.      here r 4 + !                    \ poke the address in the code
  298.      0 ,                             \ put a 0 in the data area...
  299.      [ ' clrchar cell- @ ] literal   \ get sfa contents...
  300.      VARIABLE_ID or
  301.      SETVARSFA  r@ cell- !           \ and make this the same
  302.      unsmudge
  303.      rdrop
  304.   ELSE
  305.      \
  306.      \ compiling to a module
  307.      \
  308.      [compile] :
  309.      compile MyRTS+2
  310.      [compile] ;
  311.      0 ,
  312.   THEN
  313. ;
  314.  
  315. max-inline !
  316.  
  317. variable Hash-Damaged
  318. variable HASH-#K
  319.  
  320. : turnkeying?  turnkeying @  ;
  321.  
  322. \ ---------------------------  STRINGS and the NUMBER PRINTER ROUTINES...
  323.  
  324. include jf:inline
  325. include jf:strings
  326.  
  327. max-inline @  6 max-inline !
  328.  
  329. : USER   ( -- , <name> , allocate a user variable )
  330.   user# @ cell/  #u @ < not  
  331.   ?abort" USER area exhausted, increase #U, then SAVE-FORTH"
  332.   :create                          \ make the name field...
  333.   here >r                         \ save addr...
  334.   ' s0   ( fromaddr -- )          \ asm args to move code...
  335.   r   ( fromaddr toaddr -- )
  336.   [ ' s0 cell- @ $ ffff and 2+ ] literal ( fromaddr toaddr cnt -- )
  337.   dup >r  move r> allot
  338.   user# @  r 4 + w!              \ now patch the correct offset...
  339.   0  up@ user# @ +  !             \ init the uservar to 0...
  340.   cell user#  +!                  \ get user# ready for next time...
  341.   [ ' s0 cell- @ ] literal        \ get s0's sfa contents...
  342.   USER_ID or
  343.   SETVARSFA r> cell- !            \ and make this the same
  344.   unsmudge
  345.   CacheClearU()  \ 00002  - requires jforth 2.08
  346. ;
  347.  
  348. max-inline !
  349.  
  350. : HOLD          -1 HLD +! HLD @ C! ;
  351.  
  352. : SIGN          ROT 0< IF $ 2D HOLD THEN  ;
  353.  
  354. : #>  ( D1 --- ADDR COUNT )   2DROP   HLD @ PAD OVER -
  355.       (COMMAS) @  IF
  356.         HLD @ C@ $ 2D =   ( ADDR CNT FLAG )   ( ISIT - ? )
  357.            IF  HLD @ 1+ C@ $ 2C =  ( ADDR CNT FLAG )
  358.                IF   $ 2D HLD @ 1+ C!
  359.                     1- SWAP 1+ SWAP  ( ADJUST ADDR & CNT )
  360.                THEN
  361.            ELSE HLD @ C@ $ 2C =
  362.                 IF 1- SWAP 1+ SWAP
  363.                 THEN
  364.            THEN   THEN  ;
  365.  
  366. : M/MOD  ( u1 u2 --- u3 u4  )  >R 0 R@ U/ R> SWAP >R U/ R> ;
  367.  
  368. : <#     ( --- )  0 #DIGS !    PAD HLD ! ;
  369.  
  370. \ : /      ( N1 N2 --- N1/N2 )   /MOD SWAP DROP ;
  371.  
  372. : +-    0<  IF   negate   THEN   ;
  373.  
  374. : M/   ( d1 n1 --- rem quo)    OVER >R >R DABS R@ ABS U/
  375.       R> R@ XOR  +-  SWAP R> +- SWAP ;
  376.  
  377. : DIGS/,  ( --DIGITS-PER-, ) BASE @ DUP $ 10 = SWAP 2 = OR if 4 else 3 then ;
  378. ( The above word, DIGS/, or DIGITS-PER-COMMA, will return the )
  379. ( value 4 for HEX or BINARY modes...all others return 3.      )
  380.  
  381. : COMMAS     1 (COMMAS) !  ;
  382.  
  383. : NO-COMMAS  0 (COMMAS) !  ;
  384.  
  385. max-inline @  6 max-inline !
  386. : #             BASE @ M/MOD ROT 9 OVER < IF 7 + THEN
  387.                 $ 30 + HOLD
  388.                 (COMMAS) @
  389.                    IF   1 #DIGS +!  #DIGS @  DIGS/, < 0=
  390.                         IF   $ 2C HOLD  0 #DIGS !
  391.                         THEN
  392.                    THEN  ;
  393. max-inline !
  394.  
  395. : #S            BEGIN # 2DUP OR 0= UNTIL ;
  396.  
  397.  
  398. : D.R   ( d1 n1 --- )  >R SWAP OVER DABS <# #S SIGN #> R>
  399.                 OVER - SPACES TYPE ;
  400.  
  401. : D.  ( d1 --- )   0 D.R SPACE ;
  402.  
  403. : .r >r s->d r> d.r ;
  404.  
  405. : (.)   ( N --- )   S->D D. ;
  406.  
  407. ' (.) '. ! 
  408.  
  409. : *   ( n1 n2 --- n3 )  M* DROP ;
  410.  
  411. : */MOD   ( n1 n2 --- rem quo )  >R M* R> M/ ;
  412.  
  413. : */  ( n1 n2 n3 --- n1*n2/n3 )  */MOD SWAP DROP ;
  414.  
  415. : U.   ( n --- )  0 D. ;
  416.  
  417. decimal
  418.  
  419. \ -------------------------------------  +BOOTS & other includes ...
  420.  
  421. max-inline @  6 max-inline !
  422. \ +BOOTS is used to reference the 'BOOTAREA' that initializes the
  423. \ 'kernal-defined' part of the userarea at COLD.  This area is totally
  424. \ overwritten by FREEZE and is how the image is 'frozen'.
  425.  
  426. : +Boots  ( useraddr--bootsaddr )
  427.   dup spare >
  428.   IF    .err  ." illegal +BOOTS, user variable not in kernal" quit  
  429.   THEN  up@ - userboots +
  430. ;
  431.  
  432.  
  433. \ need some vectors...'only, 'forth, 'definitions...init when 'vocs' loads
  434. user 'only          ' noop 'only !
  435. user 'forth         ' noop 'forth !
  436. user 'definitions   ' noop 'definitions !
  437. : FREEZE  ( -- , freeze the image where it is for cold )
  438.   'only        @execute
  439.   'forth       @execute
  440.   'definitions @execute
  441.   context   @ COLDcontext   !
  442.   KernalNFA @ COLDKernalNFA !
  443.   here fence !
  444.   ColdVocNFAS   #vocs @  0     \ initialize the voc pointers for cold...
  445.   DO   dup @ @   over cell+ !
  446.        [ 2 cells ] literal +
  447.   LOOP drop
  448.   up@  userboots  [ spare up@ - cell+ ] literal move
  449.   FreezeKDefered
  450. ;
  451. max-inline !
  452.  
  453. decimal
  454.  
  455.  
  456. 1  0 shift constant MEMF_PUBLIC
  457. 1  1 shift constant MEMF_CHIP
  458. 1  2 shift constant MEMF_FAST
  459. 1 16 shift constant MEMF_CLEAR
  460. 1 17 shift constant MEMF_LARGEST
  461.  
  462.  
  463. $ 4e75 constant rts-code
  464. $ 4eb9 constant jsr-code
  465. $ 6100 constant bsr-code
  466.  
  467.  
  468. : mod   /mod drop  ;
  469.  
  470. : ERASE  ( FROM CNT --- )  0 FILL ;
  471.  
  472. \ ?PAUSE ------------------------------------------------------
  473.  
  474.  
  475. include jf:case
  476. include jf:create_does
  477. include jf:.if
  478. include jf:defer
  479.  
  480. defer hash.off      ' noop  is hash.off
  481. defer hash.forget   ' noop  is hash.forget
  482. defer >#METHODS     ' noop  is >#METHODS     ( for clone to unravel a class )
  483. defer >CFATABLE     ' noop  is >CFATABLE     ( for clone to unravel a :class )
  484. defer >LASTIVAR     ' noop  is >LASTIVAR     ( for clone to unravel an ivar )
  485. defer >PREVIVAR     ' noop  is >PREVIVAR     ( for clone to unravel an ivar )
  486. defer >IVARCLASS    ' noop  is >IVARCLASS    ( for clone to unravel an ivar )
  487. \ defer FixHash;    ' noop  is FixHash;      ( now obsolete Hash support )
  488. defer CancelKey?    ' false is CancelKey?
  489. defer CancelNow?    ' noop  is CancelNow?
  490. defer UserCleanUp   ' noop  is UserCleanUp   \ for CLONED IMAGES ONLY!
  491. defer ErrorCleanUp  ' noop  is ErrorCleanUp  \ for CLONED IMAGES ONLY!
  492.  
  493. variable hash-state
  494.  
  495. turnkeying? .IF
  496. : (PAUSE)  key drop key drop  ;
  497. .ELSE
  498. max-inline @  6 max-inline !
  499. ( MOD: PLB 8/8/88 - Pause extracted. )
  500. : (PAUSE)  ( -- , do one line of forth input )
  501.      flushemit  pushtib
  502.      xblk @ >r  ( 00001 )  fblk @ >r  blk @ >r     sp@ >r  out @ >r
  503.      fblk off  blk off  xblk off  0 out !
  504. \
  505.      query    r> out +!   interpret
  506. \
  507.      r> set-sp   r> blk !  r> fblk !  r> xblk !  ( 00001 )
  508.      pulltib  
  509. ;
  510. max-inline !
  511. .THEN
  512.  
  513. : ?PAUSE   ( -- )   ?terminal
  514.   IF (pause)
  515.   THEN
  516. ;
  517.  
  518. include jf:fastio
  519. fast
  520.  
  521. include jf:files
  522.  
  523. \  ----------------------------------------------------------
  524. decimal
  525.  
  526. turnkeying? .IF
  527. : .s ;
  528. : u.s ;
  529. .ELSE
  530. max-inline @  6 max-inline !
  531. variable .S-UNSIGNED
  532. : .S   ( -- , non-destructive stack print )
  533.   >newline   depth dup 0<
  534.   IF   ." Stack Underflow!!! " quit
  535.   THEN
  536.   IF  ." Stack> " depth dup  cells  0
  537.       DO   s0 @  i - 8 - @
  538.           .s-unsigned @ IF u. ELSE . THEN
  539.           cell  ( Use . instead of U. , PLB )
  540.       +LOOP drop
  541.   ELSE ." Stack Empty "
  542.   THEN flushemit
  543.   .s-unsigned off
  544. ;
  545. : U.S (  -- , print stack unsigned )
  546.     .s-unsigned on
  547.     .s
  548. ;
  549. max-inline !
  550.  
  551. .THEN
  552.  
  553. max-inline @  6 max-inline !
  554. \ dump --------------------------------------------------------
  555.  
  556. : N>TEXT ( n -- addr count , convert N to text representation)
  557.     s->d    swap over dabs
  558.     <# #S SIGN #>
  559. ;
  560.  
  561. : #DIGITS  ( n1 -- #hex columns to print )
  562.     n>text nip
  563. ;
  564.  
  565. turnkeying? not .IF
  566.  
  567. : .HX ( n1-- )  dup 9 >
  568.   IF   $ 37 +
  569.   ELSE $ 30 +
  570.   THEN emit
  571. ;
  572.  
  573. user dumpcol
  574. : dumphdr  ( stadd-- )  cr
  575.   dumpcol @ 1+ spaces
  576.   $ 0f and dup $ 10 + swap 2dup
  577.   DO   i $ 0f and 2 spaces  .hx
  578.   LOOP 2 spaces 
  579.   DO   i $ 0f and   .hx
  580.   LOOP
  581. ;
  582.  
  583. : dump   ( adr cnt -- )
  584.   base @ >r   hex
  585.   over #digits >r   2dup + #digits r> max dumpcol !  \ calc offset for header..
  586.   over + swap dup rot rot
  587.   DO  dup i -  $ 17 mod  0=
  588.       IF  dup dumphdr
  589.       THEN   >r ?pause  cr r>
  590.       i  dumpcol @  .r space
  591.       i $ 10 +  i 2dup
  592.       DO   i c@ space  dup 2/ 2/ 2/ 2/ .hx  $ 0f and .hx
  593.       LOOP  2 spaces
  594.       DO   i c@ dup $ 20 <  over $ 7e > or
  595.            IF   drop $ 2e
  596.            THEN emit
  597.       LOOP   $ 10
  598.   +LOOP   cr  drop   r> base !
  599. ;
  600.  
  601.  
  602. user linelimit  decimal 75 linelimit !
  603.  
  604. : ?wrap  ( #columns -- )  linelimit @ swap -  out @ swap  < not
  605.   IF   ?pause cr
  606.   THEN
  607. ;
  608.  
  609.  
  610. : emit-to-column  ( char column# -- )  dup   out @ < 0=
  611.   IF   linelimit @ 0
  612.        DO    out @ over = ?leave  over emit
  613.        LOOP
  614.   THEN 2drop
  615. ;
  616.  
  617. .THEN
  618.  
  619. decimal
  620.  
  621. : load-file include ;
  622.  
  623. include jf:strings_extra
  624.  
  625. turnkeying? NOT .IF
  626. include jf:find-data
  627. .THEN
  628. max-inline !
  629.  
  630. \ can now use ?include jf:!!!!!
  631. include jf:utilities
  632.  
  633. : LOOPCHK  ( -- , abort if unresolved loop on user stack )
  634.   usp cell-    us-depth 0
  635.   DO
  636.      dup @   ( -- us@ )
  637.      do_flag ?do_flag within?
  638.      IF
  639.         " Unresolved LOOP structure in "  pad $move
  640.         latest 1+  latest c@ $ 1f and   pad $append
  641.         pad $error
  642.      THEN  cell-
  643.   LOOP
  644.   drop
  645. ;        ' loopchk 'loopchk !
  646.  
  647. include jf:match
  648. include jf:files_extra
  649. include jf:vocs
  650.  
  651. max-inline @  6 max-inline !
  652. : y/n  ( -- flag )
  653.   ." ...Yes, No or Quit (y/n/q)? " flushemit
  654.   true
  655.   BEGIN   key  bl or      ( flag char -- )
  656.           ascii y over =
  657.           IF    emit        drop true false
  658.           ELSE  ascii n over =
  659.                 IF    emit   drop false false
  660.                 ELSE  ascii q =
  661.                       IF     quit
  662.                       THEN  ( true -- )  true
  663.                 THEN
  664.           THEN
  665.   WHILE   7 emit
  666.   REPEAT  cr  ;
  667.  
  668. turnkeying? NOT .IF
  669. include? (hello) jf:SayHello
  670. include jf:fromfile
  671. .THEN
  672.  
  673. include jf:calls
  674. include jf:save-forth
  675. include jf:cleanup
  676. include jf:forget
  677.  
  678. : ROLL ( NX ... N0 X --- NX-1 ... N0 NX )
  679.     >r r@ ( -- nx..n0 x )
  680.     pick sp@ ( -- nx..n0 NX &n0 )
  681.     dup cell- swap ( -- nx..n0 NX &NX &n0 )
  682.     r> 1+ cells  ( -- nx..no nx &NX &n0 [x+1]cells )
  683.     cmove> drop
  684. ; ( -- nx-1..n0 nx )
  685.  
  686. : RECURSE  ( --- )
  687.    ?comp latest name> cfa,
  688. ;  IMMEDIATE   
  689.  
  690. : RDEPTH ( -- #r )
  691.     r0 @ rp@ - cell/
  692. ;
  693.  
  694. : TAIL  latest c@ $ 20 and
  695.   IF
  696.      latest name> cell- dup @ $ 0400,0000 or swap !
  697.   ELSE
  698.      >newline cr
  699.      ." TAIL must occur before the ; or END-CODE statement" cr
  700.      ." TAIL operation ignored" cr
  701.      where
  702.   THEN
  703. ; immediate
  704.  
  705. \ Support to allow the Debugger and locals to work with ODE.
  706. defer ;M immediate
  707. variable current-method
  708.  
  709. \
  710. turnkeying? NOT .IF
  711.  
  712. : memcells?  ( memblk -- size )  dup
  713.   IF    freebyte cell/    THEN  ;
  714. : .on/off  ( flag -- )  4 spaces
  715.   IF   ."  on"
  716.   ELSE ." off"  THEN  ;
  717.  
  718. : .any?  ( n1 -- ) dup 0=
  719.   IF  3 spaces ." none" drop
  720.   ELSE 7 .r  THEN  ;
  721.  
  722. : .(K)  ( num -- )
  723.   1024 /mod swap
  724.   IF
  725.      1+
  726.   THEN
  727.   ascii ( emit     0 .r     ." K)"
  728. ;
  729.  
  730. : map  ( -- )
  731.   cr ." JForth image size  = " up@ #u @ cells + .any?
  732.   cr ." Current HERE       = " here .any?
  733.   cr ." Dictionary left    = " sp@ here - .any?
  734.   cr ." Vocabularies used  = " #vocs @ .any?
  735.   cr ." Vocabularies left  = " Maxvocs #vocs @ - .any?
  736.   cr ." USER vars in use   = " user# @ cell/ dup .any?
  737.   cr ." USER vars left     = " #u @ swap - .any?
  738.   cr ." Long Relocations   = " #relocs @ .any?
  739.   cr ." Files open         = " fcloseatbye @ memcells? .any?
  740.   cr ." Memory areas open  = " freeatbye   @ memcells? .any?
  741.   cr ." Current max-inline = " max-inline @ .any?
  742.   cr ." Verify-Libs        = " verify-libs @ .on/off
  743.   cr ." Fileheaders        = " fileheaders @ .on/off
  744.   " .MODULES" find
  745.   IF
  746.      cr ." MODULE Status:"  dup execute
  747.   THEN
  748.   drop
  749.   hash-state @
  750.   IF
  751.      >newline
  752.      ." Using HASHed Vocabulary Search.  "
  753.      hash-#k @ 1024 * .(K)  \ will line up with .MODULES (#K)
  754.   THEN
  755.   >newline  ;
  756.  
  757. .THEN
  758. max-inline !
  759.  
  760. 100 #k !    \ for 'minimum' image
  761. 600 #U !   \ leaves about 150 available
  762.  
  763. turnkeying? NOT .IF
  764. Verify-Libs on
  765. .ELSE
  766. Verify-Libs off
  767. .THEN
  768.  
  769. here fence !
  770.  
  771. cr ." You will now save the current JForth image to"   \ 00003
  772. cr ." a file called MINIMUM." cr
  773.  
  774. cr ." If 'com:' is on a hard disk, you probably have room"
  775. cr ." to save MINIMUM there (with the other executables)." cr
  776.  
  777. cr ." If 'com:' is on a floppy, you will have to save MINIMUM"
  778. cr ." on another disk (possibly ram:...it's just over 100k in size)" cr
  779.  
  780. cr ." NOTE: the MINIMUM image is only useful during sysgen...you"
  781. cr ."       don't really NEED to save it permanently." cr
  782.  
  783. cr ." Enter:    SAVE-FORTH COM:Minimum   or  SAVE-FORTH <other>"
  784. cr
  785.  
  786.